home *** CD-ROM | disk | FTP | other *** search
- /*
- (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
- Copying of this file is authorized to users who have executed the true and
- proper "License Agreement for Kyoto Common LISP" with SIGLISP.
- */
-
- /*
- main.c
- IMPLEMENTATION-DEPENDENT
- */
-
- #include "include.h"
-
- bool saving_system = FALSE;
-
- #ifdef BSD
- #include <sys/time.h>
- #include <sys/resource.h>
- #endif
-
- #ifdef AOSVS
-
- #endif
-
- #define MAXPATHLEN 1024
-
- char lisp_implementation_version[] = "June 1987";
-
- char system_directory[MAXPATHLEN];
- object siVsystem_directory;
- #ifdef UNIX
- char *kcl_self;
- #endif
-
- char stdin_buf[BUFSIZ];
- char stdout_buf[BUFSIZ];
-
- int debug; /* debug switch */
- int initflag = FALSE; /* initialized flag */
-
- int real_maxpage;
- object siVlisp_maxpages;
-
- object siClisp_pagesize;
-
- object siStop_level;
-
- int ARGC;
- char **ARGV;
- #ifdef UNIX
- char **ENVP;
- #endif
-
- static object defmacro_data;
- static object evalmacros_data;
- static object top_data;
- static object module_data;
-
- char *merge_system_directory();
-
- int cssize;
-
- #ifdef UNIX
- main(argc, argv, envp)
- int argc;
- char **argv, **envp;
- #else
- main(argc, argv)
- int argc;
- char **argv;
- #endif
- {
- FILE *i;
- #ifdef BSD
- struct rlimit rl;
- #endif
- #ifdef AOSVS
-
-
-
- #endif
-
- setbuf(stdin, stdin_buf);
- setbuf(stdout, stdout_buf);
-
- ARGC = argc;
- ARGV = argv;
- #ifdef UNIX
- ENVP = envp;
- #endif
-
- #ifdef UNIX
- /*
- if (argv[0][0] != '/')
- error("can't get the program name");
- */
- kcl_self = argv[0];
- if (!initflag) {
- strcpy(system_directory, argv[0]);
- if (system_directory[0] != '/')
- strcpy(system_directory, "./");
- else {
- int j;
-
- for (j = strlen(system_directory);
- system_directory[j-1] != '/'; --j)
- ;
- system_directory[j] = '\0';
- }
- }
- #endif
- #ifdef AOSVS
-
-
-
-
-
-
-
-
-
-
-
-
- #endif
-
- if (!initflag && argc > 1) {
- #ifdef UNIX
- if (argv[1][strlen(argv[1])-1] != '/')
- #endif
- #ifdef AOSVS
-
- #endif
- error("can't get the system directory");
- strcpy(system_directory, argv[1]);
- }
-
- GBC_enable = FALSE;
-
- vs_top = vs_base = vs_org;
- vs_limit = &vs_org[VSSIZE];
- frs_top = frs_org-1;
- frs_limit = &frs_org[FRSSIZE];
- bds_top = bds_org-1;
- bds_limit = &bds_org[BDSSIZE];
- ihs_top = ihs_org-1;
- ihs_limit = &ihs_org[IHSSIZE];
- cs_org = &argc;
-
- cssize = CSSIZE;
-
- #ifdef BSD
- getrlimit(RLIMIT_STACK, &rl);
- cssize = rl.rlim_cur/4 - 4*CSGETA;
- #endif
-
- #ifdef AV
- cs_limit = cs_org - cssize;
- #endif
- #ifdef MV
-
- #endif
-
- set_maxpage();
-
- if (initflag) {
- if (saving_system) {
- saving_system = FALSE;
- alloc_page(-(holepage + nrbpage));
- }
-
- initflag = FALSE;
- GBC_enable = TRUE;
- vs_base = vs_top;
- ihs_push(Cnil);
- lex_new();
- vs_base = vs_top;
- #ifdef AOSVS
-
-
- #endif
- interrupt_enable = TRUE;
- #ifdef UNIX
- init_interrupt();
- #endif
- siVlisp_maxpages->s.s_dbind = make_fixnum(real_maxpage);
- initflag = TRUE;
- super_funcall(siStop_level);
- exit(0);
- }
-
- printf("KCl (Kyoto Common Lisp) %s %d pages\n",
- lisp_implementation_version,
- MAXPAGE);
- fflush(stdout);
-
- init();
-
- vs_base = vs_top;
- ihs_push(Cnil);
- lex_new();
-
- GBC_enable = TRUE;
-
- CMPtemp = CMPtemp1 = CMPtemp2 = CMPtemp3 = OBJNULL;
-
- init_init();
-
- Vpackage->s.s_dbind = user_package;
-
- lex_new();
- vs_base = vs_top;
- initflag = TRUE;
-
- interrupt_enable = TRUE;
- #ifdef UNIX
- init_interrupt();
- #endif
-
- /* Primitive read-eval-print loop for debugging. */
- /*
- for (;;) {
- vs_base = vs_top;
- vs_push(code_char('>'));
- Lwrite_char();
- vs_base = vs_top;
- Lfinish_output();
- vs_base = vs_top;
- Lread();
- Leval();
- vs_top = vs_base+1;
- Lprin1();
- vs_base = vs_top;
- Lterpri();
- }
- */
-
- /* Now, init.lsp is loaded by si:top-level. */
- /*
- #ifdef UNIX
- if ((i = fopen("./init.lsp", "r")) != NULL) {
- fclose(i);
- load("./init.lsp");
- }
- #endif
- #ifdef AOSVS
-
-
-
-
- #endif
- */
-
- super_funcall(siStop_level);
-
- }
-
- init()
- {
- int j;
-
- init_alloc();
-
- Cnil_body.t = (short)t_symbol;
- Cnil_body.s_dbind = Cnil;
- Cnil_body.s_sfdef = NOT_SPECIAL;
- Cnil_body.s_fillp = 3;
- Cnil_body.s_self = "NIL";
- Cnil_body.s_gfdef = OBJNULL;
- Cnil_body.s_plist = Cnil;
- Cnil_body.s_hpack = Cnil;
- Cnil_body.s_stype = (short)stp_constant;
- Cnil_body.s_mflag = FALSE;
-
- Ct_body.t = (short)t_symbol;
- Ct_body.s_dbind = Ct;
- Ct_body.s_sfdef = NOT_SPECIAL;
- Ct_body.s_fillp = 1;
- Ct_body.s_self = "T";
- Ct_body.s_gfdef = OBJNULL;
- Ct_body.s_plist = Cnil;
- Ct_body.s_hpack = Cnil;
- Ct_body.s_stype = (short)stp_constant;
- Ct_body.s_mflag = FALSE;
-
- init_symbol();
-
- init_package();
-
- Cnil->s.s_hpack = lisp_package;
- import(Cnil, lisp_package);
- export(Cnil, lisp_package);
-
- Ct->s.s_hpack = lisp_package;
- import(Ct, lisp_package);
- export(Ct, lisp_package);
-
- Squote = make_ordinary("QUOTE");
- enter_mark_origin(&Squote);
- Sfunction = make_ordinary("FUNCTION");
- enter_mark_origin(&Sfunction);
- Slambda = make_ordinary("LAMBDA");
- enter_mark_origin(&Slambda);
- Slambda_block = make_ordinary("LAMBDA-BLOCK");
- enter_mark_origin(&Slambda_block);
- Slambda_closure = make_ordinary("LAMBDA-CLOSURE");
- enter_mark_origin(&Slambda_closure);
- Slambda_block_closure = make_ordinary("LAMBDA-BLOCK-CLOSURE");
- enter_mark_origin(&Slambda_block_closure);
- Sspecial = make_ordinary("SPECIAL");
- enter_mark_origin(&Sspecial);
-
- init_typespec();
- init_number();
- init_character();
- init_file();
- init_read();
- init_bind();
- init_pathname();
- init_print();
- init_GBC();
-
- #ifdef UNIX
- #ifndef DGUX
- init_unixfasl();
- init_unixsys();
- init_unixsave();
- #else
-
-
-
- #endif
- #endif
-
- #ifdef AOSVS
-
-
-
- #endif
-
- init_alloc_function();
- init_array_function();
- init_character_function();
- init_file_function();
- init_list_function();
- init_package_function();
- init_pathname_function();
- init_predicate_function();
- init_print_function();
- init_read_function();
- init_sequence_function();
- init_structure_function();
- init_string_function();
- init_symbol_function();
- init_typespec_function();
- init_hash();
- init_cfun();
-
- #ifdef UNIX
- init_unixfsys();
- init_unixtime();
- #endif
- #ifdef AOSVS
-
-
- #endif
-
- init_eval();
- init_lex();
- init_prog();
- init_catch();
- init_block();
- init_macros();
- init_conditional();
- init_reference();
- init_assignment();
- init_multival();
- init_error();
- init_let();
- init_mapfun();
- init_iteration();
- init_toplevel();
-
- init_cmpaux();
-
- init_main();
-
- init_format();
-
- #ifdef AOSVS
-
- #endif
- init_interrupt1();
- }
-
- /* init_init is now defined in init_system.c */
- /*
- init_init()
- {
- load(merge_system_directory("export.lsp"));
-
- #ifdef UNIX
- defmacro_data = read_fasl_data(merge_system_directory("defmacro.o"));
- enter_mark_origin(&defmacro_data);
- init_defmacro(NULL, 0, defmacro_data);
- evalmacros_data
- = read_fasl_data(merge_system_directory("evalmacros.o"));
- enter_mark_origin(&evalmacros_data);
- init_evalmacros(NULL, 0, evalmacros_data);
- top_data = read_fasl_data(merge_system_directory("top.o"));
- enter_mark_origin(&top_data);
- init_top(NULL, 0, top_data);
- module_data = read_fasl_data(merge_system_directory("module.o"));
- enter_mark_origin(&module_data);
- init_module(NULL, 0, module_data);
- #endif
- #ifdef AOSVS
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- #endif
-
- load(merge_system_directory("autoload.lsp"));
- }
- */
-
- char *
- merge_system_directory(s)
- {
- static char buff[MAXPATHLEN];
- extern char *strcat();
-
- strcpy(buff, system_directory);
- return(strcat(buff, s));
- }
-
- vs_overflow()
- {
- if (vs_limit > vs_org + VSSIZE)
- error("value stack overflow");
- vs_limit += VSGETA;
- FEerror("Value stack overflow.", 0);
- }
-
- bds_overflow()
- {
- --bds_top;
- if (bds_limit > bds_org + BDSSIZE)
- error("bind stack overflow");
- bds_limit += BDSGETA;
- FEerror("Bind stack overflow.", 0);
- }
-
- frs_overflow()
- {
- --frs_top;
- if (frs_limit > frs_org + FRSSIZE)
- error("frame stack overflow");
- frs_limit += FRSGETA;
- FEerror("Frame stack overflow.", 0);
- }
-
- ihs_overflow()
- {
- --ihs_top;
- if (ihs_limit > ihs_org + IHSSIZE)
- error("invocation history stack overflow");
- ihs_limit += IHSGETA;
- FEerror("Invocation history stack overflow.", 0);
- }
-
- cs_overflow()
- {
- #ifdef AV
- if (cs_limit < cs_org - cssize)
- error("control stack overflow");
- cs_limit -= CSGETA;
- #endif
- #ifdef MV
-
-
-
- #endif
- FEerror("Control stack overflow.", 0);
- }
-
- end_of_file()
- {
- error("end of file");
- }
-
- error(s)
- {
- printf("\nUnrecoverable error: %s.\n", s);
- fflush(stdout);
- #ifdef UNIX
- abort();
- #endif
- #ifdef AOSVS
-
- #endif
- }
-
- Lby()
- {
- #ifdef UNIX
- int i;
-
- if (vs_top - vs_base == 0)
- i = 0;
- else if (vs_top - vs_base == 1) {
- if (type_of(vs_base[0]) == t_fixnum)
- i = fix(vs_base[0]);
- else
- FEerror("Illegal exit code: ~S.", 1, vs_base[0]);
- } else
- too_many_arguments();
- printf("Bye.\n");
- exit(i);
- #endif
- #ifdef AOSVS
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- #endif
- }
-
- c_trace()
- {
- #ifdef AOSVS
-
- #endif
- }
-
- siLargc()
- {
- check_arg(0);
- vs_push(make_fixnum(ARGC));
- }
-
- siLargv()
- {
- int i;
-
- check_arg(1);
- if (type_of(vs_base[0]) != t_fixnum ||
- (i = fix(vs_base[0])) < 0 ||
- i >= ARGC)
- FEerror("Illegal argument index: ~S.", 1, vs_base[0]);
- vs_base[0] = make_simple_string(ARGV[i]);
- }
-
- #ifdef UNIX
- siLgetenv()
- {
- char name[256];
- int i;
- char *value;
- extern char *getenv();
-
- check_arg(1);
- check_type_string(&vs_base[0]);
- if (vs_base[0]->st.st_fillp >= 256)
- FEerror("Too long name: ~S.", 1, vs_base[0]);
- for (i = 0; i < vs_base[0]->st.st_fillp; i++)
- name[i] = vs_base[0]->st.st_self[i];
- name[i] = '\0';
- if ((value = getenv(name)) != NULL)
- vs_base[0] = make_simple_string(value);
- else
- vs_base[0] = Cnil;
- }
- #endif
-
- object *vs_marker;
-
- siLmark_vs()
- {
- check_arg(0);
- vs_marker = vs_base;
- vs_base[0] = Cnil;
- }
-
- siLcheck_vs()
- {
- check_arg(0);
- if (vs_base != vs_marker)
- FEerror("Value stack is flawed.", 0);
- vs_base[0] = Cnil;
- }
-
- siLreset_stack_limits(arg)
- {
- check_arg(0);
- if (vs_top < vs_org + VSSIZE)
- vs_limit = vs_org + VSSIZE;
- else
- error("can't reset vs_limit");
- if (bds_top < bds_org + BDSSIZE)
- bds_limit = bds_org + BDSSIZE;
- else
- error("can't reset bds_limit");
- if (frs_top < frs_org + FRSSIZE)
- frs_limit = frs_org + FRSSIZE;
- else
- error("can't reset frs_limit");
- if (ihs_top < ihs_org + IHSSIZE)
- ihs_limit = ihs_org + IHSSIZE;
- else
- error("can't reset ihs_limit");
- #ifdef AV
- if (&arg > cs_org - cssize + 16)
- cs_limit = cs_org - cssize;
- #endif
- #ifdef MV
-
-
- #endif
- else
- error("can't reset cs_limit");
- vs_base[0] = Cnil;
- }
-
- siLinit_system()
- {
- check_arg(0);
- init_system();
- vs_base[0] = Cnil;
- }
-
- siLaddress()
- {
- check_arg(1);
- vs_base[0] = make_fixnum((int)vs_base[0]);
- }
-
- siLnani()
- {
- check_arg(1);
- vs_base[0] = (object)fixint(vs_base[0]);
- }
-
- siLinitialization_failure()
- {
- check_arg(0);
- printf("lisp initialization failed\n");
- exit(0);
- }
-
- Lidentity()
- {
- check_arg(1);
- }
-
- Llisp_implementation_version()
- {
- check_arg(0);
- vs_push(make_simple_string(lisp_implementation_version));
- vs_base[0] = Cnil;
- }
-
- siLsave_system()
- {
- int i;
-
- #ifdef AOSVS
-
- #endif
- saving_system = TRUE;
- GBC(t_contiguous);
-
- #ifdef BSD
- brk(core_end);
- #endif
-
- #ifdef DGUX
-
- #endif
-
- #ifdef AOSVS
-
-
-
-
- #endif
- cbgbccount = 0;
- rbgbccount = 0;
- for (i = 0; i < (int)t_end; i++)
- tm_table[i].tm_gbccount = 0;
- Lsave();
- saving_system = FALSE;
- alloc_page(-(holepage+nrbpage));
- }
-
- init_main()
- {
- make_function("BY", Lby);
- make_function("BYE", Lby);
-
- make_function("IDENTITY", Lidentity);
-
- siStop_level=make_si_ordinary("TOP-LEVEL");
- enter_mark_origin(&siStop_level);
-
- make_si_function("ARGC", siLargc);
- make_si_function("ARGV", siLargv);
-
- #ifdef UNIX
- make_si_function("GETENV", siLgetenv);
- #endif
-
- make_si_function("MARK-VS", siLmark_vs);
- make_si_function("CHECK-VS", siLcheck_vs);
-
- make_si_function("RESET-STACK-LIMITS", siLreset_stack_limits);
-
- make_si_function("INIT-SYSTEM", siLinit_system);
-
- make_si_function("ADDRESS", siLaddress);
- make_si_function("NANI", siLnani);
-
- make_si_function("INITIALIZATION-FAILURE",
- siLinitialization_failure);
-
- make_function("LISP-IMPLEMENTATION-VERSION",
- Llisp_implementation_version);
-
- siVlisp_maxpages =
- make_si_special("*LISP-MAXPAGES*", make_fixnum(real_maxpage));
-
- siClisp_pagesize =
- make_si_constant("LISP-PAGESIZE", make_fixnum(PAGESIZE));
-
- siVsystem_directory =
- make_si_special("*SYSTEM-DIRECTORY*",
- make_simple_string(system_directory));
-
- make_special("*FEATURES*",
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil)));
-
- #ifdef VAX
- make_special("*FEATURES*",
- make_cons(make_ordinary("VAX"),
- make_cons(make_ordinary("UNIX"),
- make_cons(make_ordinary("BSD"),
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil))))));
- #endif
-
- #ifdef SUN
- make_special("*FEATURES*",
- make_cons(make_ordinary("SUN"),
- make_cons(make_ordinary("MC68K"),
- make_cons(make_ordinary("IEEE-FLOATING-POINT"),
- make_cons(make_ordinary("UNIX"),
- make_cons(make_ordinary("BSD"),
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil))))))));
- #endif
-
- #ifdef SUN2R3
- make_special("*FEATURES*",
- make_cons(make_ordinary("SUN"),
- make_cons(make_ordinary("MC68K"),
- make_cons(make_ordinary("IEEE-FLOATING-POINT"),
- make_cons(make_ordinary("UNIX"),
- make_cons(make_ordinary("BSD"),
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil))))))));
- #endif
-
- #ifdef SUN3
- make_special("*FEATURES*",
- make_cons(make_ordinary("SUN"),
- make_cons(make_ordinary("MC68020"),
- make_cons(make_ordinary("IEEE-FLOATING-POINT"),
- make_cons(make_ordinary("UNIX"),
- make_cons(make_ordinary("BSD"),
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil))))))));
- #endif
-
- #ifdef NEWS
- make_special("*FEATURES*",
- make_cons(make_ordinary("NEWS"),
- make_cons(make_ordinary("MC68020"),
- make_cons(make_ordinary("IEEE-FLOATING-POINT"),
- make_cons(make_ordinary("UNIX"),
- make_cons(make_ordinary("BSD"),
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil))))))));
- #endif
-
- #ifdef ISI
-
-
-
-
-
-
-
-
- #endif
-
- #ifdef SEQ
-
-
-
-
-
-
-
-
- #endif
-
- #ifdef IBMRT
-
-
-
-
-
-
- #endif
-
- #ifdef ATT3B2
- make_special("*FEATURES*",
- make_cons(make_ordinary("ATT3B2"),
- make_cons(make_ordinary("IEEE-FLOATING-POINT"),
- make_cons(make_ordinary("UNIX"),
- make_cons(make_ordinary("SYSTEM-V"),
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil)))))));
- #endif
-
- #ifdef S3000
- make_special("*FEATURES*",
- make_cons(make_ordinary("S3300"),
- make_cons(make_ordinary("UNIX"),
- make_cons(make_ordinary("SYSTEM-V"),
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil))))));
- #endif
-
- #ifdef E15
- make_special("*FEATURES*",
- make_cons(make_ordinary("E15"),
- make_cons(make_ordinary("MC68K"),
- make_cons(make_ordinary("IEEE-FLOATING-POINT"),
- make_cons(make_ordinary("UNIX"),
- make_cons(make_ordinary("UNIPLUS-SYSTEM-V"),
- make_cons(make_ordinary("COMMON"),
- make_cons(make_ordinary("KCL"), Cnil))))))));
- #endif
-
- #ifdef DGUX
-
-
-
-
-
-
- #endif
-
- #ifdef AOSVS
-
-
-
-
-
- #endif
-
- make_si_function("SAVE-SYSTEM", siLsave_system);
- }
-